Collection of Tools & Utilities/Collection of Tools and Utilities.iso/ada/gnat1792.zip/gnat179b/t-adainc/s-reatim.adb

Text File | 1994-05-19 | 11KB | 383 lines

------------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--                      S Y S T E M . R E A L _ T I M E                     --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                             $Revision: 1.7 $                             --
--                                                                          --
--           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
--                                                                          --
--  GNARL is free software; you can redistribute it and/or modify it  under --
--  terms  of  the  GNU  Library General Public License as published by the --
--  Free Software Foundation; either version 2,  or  (at  your  option) any --
--  later  version.   GNARL is distributed in the hope that it will be use- --
--  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
--  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
--  eral Library Public License for more details.  You should have received --
--  a  copy of the GNU Library General Public License along with GNARL; see --
--  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
--  Ave, Cambridge, MA 02139, USA.                                          --
--                                                                          --
------------------------------------------------------------------------------

pragma Checks_On;
--  We require checks on for this body, because we rely on the constraint
--  error to keep System.Real_Time.Time values within representable range.

with System.Compiler_Exceptions;
--  Uses, function Current_Exceptions

with System.Task_Timer_Service;
--  Uses, object Objects
--        procedure Service_Entries

with System.Tasking;

with Unchecked_Conversion;

package body System.Real_Time is

   use Task_Clock;
   --  Using it for arithmetic operations

   use Tasking.Protected_Objects;
   use Tasking;

   package Timer renames System.Task_Timer_Service.Timer;

   function To_Access is new
     Unchecked_Conversion (System.Address, Protection_Access);

   -----------
   -- Clock --
   -----------

   function Clock return Time is
   begin
      return Time (Task_Clock.Machine_Specifics.Clock);
   end Clock;

   ---------
   -- "<" --
   ---------

   function "<" (Left, Right : Time) return Boolean is
   begin
      return Task_Clock.Stimespec (Left) < Task_Clock.Stimespec (Right);
   end "<";

   function "<" (Left, Right : Time_Span) return Boolean is
   begin
      return Task_Clock.Stimespec (Left) < Task_Clock.Stimespec (Right);
   end "<";

   ---------
   -- ">" --
   ---------

   function ">" (Left, Right : Time) return Boolean is
   begin
      return Right < Left;
   end ">";

   function ">" (Left, Right : Time_Span) return Boolean is
   begin
      return Right < Left;
   end ">";

   ----------
   -- "<=" --
   ----------

   function "<=" (Left, Right : Time) return Boolean is
   begin
      return not (Left > Right);
   end "<=";

   function "<=" (Left, Right : Time_Span) return Boolean is
   begin
      return not (Left > Right);
   end "<=";

   ----------
   -- ">=" --
   ----------

   function ">=" (Left, Right : Time) return Boolean is
   begin
      return not (Left < Right);
   end ">=";

   function ">=" (Left, Right : Time_Span) return Boolean is
   begin
      return not (Left < Right);
   end ">=";

   ---------
   -- "+" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "+" (Left : Time; Right : Time_Span) return Time is
   begin
      return Time (Task_Clock.Stimespec (Left) + Task_Clock.Stimespec (Right));
   end "+";

   function "+"  (Left : Time_Span; Right : Time) return Time is
   begin
      return Right + Left;
   end "+";

   function "+"  (Left, Right : Time_Span) return Time_Span is
   begin
      return Time_Span (Time (Right) + Left);
   end "+";

   ---------
   -- "-" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "-"  (Left : Time; Right : Time_Span) return Time is
   begin
      return Time (Task_Clock.Stimespec (Left) - Task_Clock.Stimespec (Right));
   end "-";

   function "-"  (Left, Right : Time) return Time_Span is
   begin
      return Time_Span (Left - Time_Span (Right));
   end "-";

   function "-"  (Left, Right : Time_Span) return Time_Span is
   begin
      return Time_Span (Time (Left) - Right);
   end "-";

   function "-"  (Right : Time_Span) return Time_Span is
   begin
      return Time_Span (-(Task_Clock.Stimespec (Right)));
   end "-";

   ---------
   -- "/" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "/"  (Left, Right : Time_Span) return integer is
      Temp_TV : Task_Clock.Stimespec;

   begin
      Temp_TV := Task_Clock.Stimespec (Left) / Task_Clock.Stimespec (Right);

      if not (Temp_TV < Task_Clock.Stimespec_Zero)  then
         return Task_Clock.Stimespec_Seconds (Temp_TV);
      end if;

      Temp_TV := -Temp_TV;
      return -Task_Clock.Stimespec_Seconds (Temp_TV);
   end "/";

   function "/"  (Left : Time_Span; Right : Integer) return Time_Span is
   begin
      return Time_Span (Task_Clock.Stimespec (Left) / Right);
   end "/";

   ---------
   -- "*" --
   ---------

   --  Note that Constraint_Error may be propagated

   function "*"  (Left : Time_Span; Right : Integer) return Time_Span is
   begin
      return Time_Span (Task_Clock.Stimespec (Left) * Right);
   end "*";

   function "*"  (Left : Integer; Right : Time_Span) return Time_Span is
   begin
      return Right * Left;
   end "*";

   -----------
   -- "abs" --
   -----------

   --  Note that Constraint_Error may be propagated

   function "abs" (Right : Time_Span) return Time_Span is
   begin
      if Right < Time_Span_Zero then
         return -Right;
      end if;

      return Right;
   end "abs";

   -----------------
   -- To_Duration --
   -----------------

   function To_Duration (FD : Time_Span) return Duration is
   begin
      return Task_Clock.Stimespec_To_Duration (Task_Clock.Stimespec (FD));
   end To_Duration;

   ------------------
   -- To_Time_Span --
   ------------------

   function To_Time_Span (D : Duration) return Time_Span is
   begin
      return Time_Span (Task_Clock.Duration_To_Stimespec (D));
   end To_Time_Span;

   -----------------
   -- Nanoseconds --
   -----------------

   function Nanoseconds (NS : integer) return Time_Span is
   begin
      return Time_Span_Unit * NS;
   end Nanoseconds;

   ------------------
   -- Microseconds --
   ------------------

   function Microseconds  (US : integer) return Time_Span is
   begin
      return Nanoseconds (US) * 1000;
   end Microseconds;

   -------------------
   --  Milliseconds --
   -------------------

   function Milliseconds (MS : integer) return Time_Span is
   begin
      return Microseconds (MS) * 1000;
   end Milliseconds;

   ------------------
   -- Delay_Object --
   ------------------

   --  Hand translated code will be provided here
   --  until the GNAT compiler can accomodate the protected objects. ???

   package body Delay_Object is

      procedure Service_Entries (Pending_Serviced : out Boolean) is
         P : System.Address;

         subtype PO_Entry_Index is Protected_Entry_Index
           range Null_Protected_Entry .. 1;

         Barriers : Barrier_Vector (1 .. 1)  :=  (others => true);
         --  No barriers. always true barrier

         E : PO_Entry_Index;

         PS : Boolean;

         Cumulative_PS : Boolean := False;

      begin
         loop
            --  Get the next queued entry or the pending call
            --  (if no barriers are true)

            Next_Entry_Call (To_Access